home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / linda.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  6KB  |  233 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;  EuLisp Module                     Copyright (C) University of Bath 1991  ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;                                                                           ;;
  9. ;;   EuLisp Module  -   Copyright (C) Codemist and University of Bath 1989   ;;
  10. ;;                                                                           ;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ;;                                                                           ;;
  15. ;; Name: linda                                                               ;;
  16. ;;                                                                           ;;
  17. ;; Author: Keith Playford                                                    ;;
  18. ;;                                                                           ;;
  19. ;; Date: 31 May 1990                                                         ;;
  20. ;;                                                                           ;;
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22.  
  23. ;;
  24.  
  25. ;; Change Log:
  26. ;;   Version 1.0 (31/5/90)
  27.  
  28. ;;
  29.  
  30. (defmodule linda
  31.  
  32.   (lists
  33.    list-operators
  34.    extras
  35.    arith
  36.    classes
  37.    streams
  38.    threads
  39.    semaphores
  40.    vectors
  41.    calls
  42.    others
  43.  
  44.    linda-base
  45.    linda-tabs) ()
  46.  
  47.   ;;
  48.  
  49.   ;; Parameters...
  50.  
  51.   ;;
  52.  
  53.   (deflocal *default-tuple-space-size* 500)
  54.  
  55.   ;;
  56.  
  57.   ;; Linda objects...
  58.  
  59.   ;;
  60.  
  61.   ;; Tuple space object...
  62.  
  63.   (defstruct linda-pool linda-object
  64.     ((lock initform (make-semaphore)
  65.        accessor linda-pool-lock)
  66.      (tuple-table initform (make-linda-tuple-table)
  67.            accessor linda-pool-tuple-table)
  68.      (max-tuples initform *default-tuple-space-size*
  69.          initargs (max-tuples)
  70.          accessor linda-pool-max-tuples)
  71.      (tuple-count initform 0
  72.           accessor linda-pool-tuple-count)
  73.      (out-blocked initform nil
  74.           accessor linda-pool-out-blocked))
  75.     constructor make-linda-pool)
  76.  
  77.   (export make-linda-pool 
  78.       linda-pool-lock
  79.       linda-pool-tuple-table
  80.       linda-pool-max-tuples
  81.       linda-pool-tuple-count
  82.       linda-pool-out-blocked)
  83.  
  84.   ;;
  85.  
  86.   ;; Basic operations...
  87.  
  88.   ;;  (linda-out <space> <tuple>)
  89.   ;;  (linda-in <space> <pattern>)
  90.   ;;  (linda-read <space> <pattern>)
  91.  
  92.   ;;
  93.  
  94.   ;; 'in'...
  95.  
  96.   ;;
  97.  
  98.   (defun linda-in (pool pattern)
  99.     (let ((lock (linda-pool-lock pool)))
  100.       (open-semaphore lock)
  101.       (let ((match (in-match (linda-pool-tuple-table pool) pattern lock)))
  102.     ((setter linda-pool-tuple-count) pool
  103.        (- (linda-pool-tuple-count pool) 1))
  104.     (if (= (linda-pool-tuple-count pool) 
  105.            (- (linda-pool-max-tuples pool) 1))
  106.       (progn
  107.         (let ((blocked (linda-pool-out-blocked pool)))
  108.           (if (null blocked) nil
  109.         (progn
  110.           (thread-start (car blocked))
  111.           ((setter linda-pool-out-blocked) pool (cdr blocked))))))
  112.       nil)
  113.     (close-semaphore lock)
  114.     (thread-reschedule)
  115.     match)))
  116.  
  117.   (defun in-match (tab pattern lock)
  118.     (let ((match (tuple-table-in tab pattern)))
  119.       (if (null match)
  120.         ;; Blocked on in...
  121.     (tilnil
  122. ;;      (print "IN-BLOCKED!!!")
  123.       (close-semaphore lock)
  124.       (thread-reschedule)
  125.       (open-semaphore lock)
  126.       (setq match (tuple-table-in tab pattern))
  127.       (null match))
  128.     match)))
  129.  
  130.   ;;
  131.  
  132.   ;; 'read'
  133.  
  134.   ;;
  135.  
  136.   (defun linda-read (pool pattern)
  137.     (let ((lock (linda-pool-lock pool)))
  138.       (open-semaphore lock)
  139.       (let ((match (read-match (linda-pool-tuple-table pool) pattern lock)))
  140.     (close-semaphore lock)
  141.     match)))
  142.  
  143.   (defun read-match (tab pattern)
  144.     (let ((match (tuple-table-read tab pattern)))
  145.       (if (null match)
  146.         ;; Blocked on read...
  147.         (progn
  148.       (close-semaphore lock)
  149.       (thread-reschedule)
  150.       (open-semaphore lock)
  151.       (read-match tab pattern))
  152.     match)))
  153.  
  154.   ;;
  155.  
  156.   ;; 'out'...
  157.  
  158.   ;;
  159.  
  160.   (defun linda-out (pool tuple)
  161.     (let ((lock (linda-pool-lock pool)))
  162.       (open-semaphore lock)
  163.       (cond ((= (linda-pool-tuple-count pool) (linda-pool-max-tuples pool))
  164.            ((setter linda-pool-out-blocked) pool
  165.          (nconc (linda-pool-out-blocked pool) 
  166.             (list (current-thread))))
  167.            (close-semaphore lock)
  168.            (print "OUT-BLOCKED")
  169.            (thread-suspend)
  170.            ;; Restarted...
  171.            (out pool tuple))
  172.         (t (tuple-table-out (linda-pool-tuple-table pool) tuple)
  173.            ((setter linda-pool-tuple-count) pool
  174.          (+ (linda-pool-tuple-count pool) 1))
  175.            (close-semaphore lock)
  176.            (thread-reschedule)    
  177.            tuple))))
  178.  
  179.   (export linda-out linda-in linda-read)
  180.  
  181.   ;;
  182.  
  183.   ;; Scheduling malarky...
  184.  
  185.   ;;
  186.  
  187.   (deflocal scheduler-active-flag nil)
  188.  
  189.   (defun linda-scheduler-active-p () scheduler-active-flag)
  190.  
  191.   (export linda-scheduler-active-p)
  192.  
  193.   (deflocal process-queue nil)
  194.  
  195.   (defun linda-queue-process (pair)
  196.     (setq process-queue (nconc process-queue (list pair)))
  197.     (car pair))
  198.  
  199.   (export linda-queue-process)
  200.  
  201.   (defmacro linda-start (fun . args)
  202.     `(let ((\@thread\@ (make-thread ,fun)))
  203.        (if (linda-scheduler-active-p)
  204.      (thread-start \@thread\@ ,@args)
  205.      (linda-queue-process (cons \@thread\@ ,args)))
  206.        \@thread\@))
  207.  
  208.   (export linda-start)
  209.  
  210.   (defun linda-scheduler () 
  211.     (print "Linda scheduler started")
  212. ;;    (print process-queue)
  213.     (setq scheduler-active-flag t)
  214.     (linda-scheduler-aux process-queue))
  215.  
  216.   (defun linda-scheduler-aux (ll)
  217.     (if (null ll) (thread-suspend)
  218.       (progn
  219.     (apply thread-start (car ll))
  220.     (linda-scheduler-aux (cdr ll)))))
  221.  
  222.   (export linda-scheduler)
  223.  
  224.   ;;
  225.  
  226.   ;; Sundry exportations...
  227.  
  228.   ;;
  229.  
  230.   ;; (export make-linda-tuple tuple *vector-size* *linda-wild-card*)
  231.  
  232. )
  233.